home *** CD-ROM | disk | FTP | other *** search
/ PC-Blue - MS DOS Public Domain Library / PC-Blue MS-DOS Public Domain Library - NYACC.iso / vol146 / xlsym.c < prev    next >
Encoding:
C/C++ Source or Header  |  1986-12-16  |  6.0 KB  |  260 lines
  1. /* xlsym - symbol handling routines */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* external variables */
  9. extern NODE *oblist,*keylist;
  10. extern NODE *s_unbound;
  11. extern NODE *xlstack;
  12. extern NODE *xlenv;
  13.  
  14. /* forward declarations */
  15. FORWARD NODE *symenter();
  16. FORWARD NODE *findprop();
  17.  
  18. /* xlenter - enter a symbol into the oblist or keylist */
  19. NODE *xlenter(name,type)
  20.   char *name;
  21. {
  22.     return (symenter(name,type,(*name == ':' ? keylist : oblist)));
  23. }
  24.  
  25. /* symenter - enter a symbol into a package */
  26. LOCAL NODE *symenter(name,type,listsym)
  27.   char *name; int type; NODE *listsym;
  28. {
  29.     NODE *oldstk,*lsym,*nsym,newsym;
  30.     int cmp;
  31.  
  32.     /* check for nil */
  33.     if (strcmp(name,"NIL") == 0)
  34.     return (NIL);
  35.  
  36.     /* check for symbol already in table */
  37.     lsym = NIL;
  38.     nsym = getvalue(listsym);
  39.     while (nsym) {
  40.     if ((cmp = strcmp(name,xlsymname(car(nsym)))) <= 0)
  41.         break;
  42.     lsym = nsym;
  43.     nsym = cdr(nsym);
  44.     }
  45.  
  46.     /* check to see if we found it */
  47.     if (nsym && cmp == 0)
  48.     return (car(nsym));
  49.  
  50.     /* make a new symbol node and link it into the list */
  51.     oldstk = xlsave(&newsym,NULL);
  52.     newsym.n_ptr = newnode(LIST);
  53.     rplaca(newsym.n_ptr,xlmakesym(name,type));
  54.     rplacd(newsym.n_ptr,nsym);
  55.     if (lsym)
  56.     rplacd(lsym,newsym.n_ptr);
  57.     else
  58.     setvalue(listsym,newsym.n_ptr);
  59.     xlstack = oldstk;
  60.  
  61.     /* return the new symbol */
  62.     return (car(newsym.n_ptr));
  63. }
  64.  
  65. /* xlsenter - enter a symbol with a static print name */
  66. NODE *xlsenter(name)
  67.   char *name;
  68. {
  69.     return (xlenter(name,STATIC));
  70. }
  71.  
  72. /* xlmakesym - make a new symbol node */
  73. NODE *xlmakesym(name,type)
  74.   char *name;
  75. {
  76.     NODE *oldstk,sym,*str;
  77.  
  78.     /* create a new stack frame */
  79.     oldstk = xlsave(&sym,NULL);
  80.  
  81.     /* make a new symbol node */
  82.     sym.n_ptr = newnode(SYM);
  83.     setvalue(sym.n_ptr,*name == ':' ? sym.n_ptr : s_unbound);
  84.     sym.n_ptr->n_symplist = newnode(LIST);
  85.     rplaca(sym.n_ptr->n_symplist,str = newnode(STR));
  86.     str->n_str = (type == DYNAMIC ? strsave(name) : name);
  87.     str->n_strtype = type;
  88.  
  89.     /* restore the previous stack frame */
  90.     xlstack = oldstk;
  91.  
  92.     /* return the new symbol node */
  93.     return (sym.n_ptr);
  94. }
  95.  
  96. /* xlsymname - return the print name of a symbol */
  97. char *xlsymname(sym)
  98.   NODE *sym;
  99. {
  100.     return (car(sym->n_symplist)->n_str);
  101. }
  102.  
  103. /* xlframe - create a new environment frame */
  104. NODE *xlframe(env)
  105.   NODE *env;
  106. {
  107.     NODE *ptr;
  108.     ptr = newnode(LIST);
  109.     rplacd(ptr,env);
  110.     return (ptr);
  111. }
  112.  
  113. /* xlbind - bind a value to a symbol */
  114. xlbind(sym,val,env)
  115.   NODE *sym,*val,*env;
  116. {
  117.     NODE *ptr;
  118.  
  119.     /* create a new environment list entry */
  120.     ptr = newnode(LIST);
  121.     rplacd(ptr,car(env));
  122.     rplaca(env,ptr);
  123.  
  124.     /* create a new variable binding */
  125.     rplaca(ptr,newnode(LIST));
  126.     rplaca(car(ptr),sym);
  127.     rplacd(car(ptr),val);
  128. }
  129.  
  130. /* xlgetvalue - get the value of a symbol (checked) */
  131. NODE *xlgetvalue(sym)
  132.   NODE *sym;
  133. {
  134.     NODE *val;
  135.     while ((val = xlxgetvalue(sym)) == s_unbound)
  136.     xlunbound(sym);
  137.     return (val);
  138. }
  139.  
  140. /* xlxgetvalue - get the value of a symbol */
  141. NODE *xlxgetvalue(sym)
  142.   NODE *sym;
  143. {
  144.     NODE *val;
  145.  
  146.     /* check for this being an instance variable */
  147.     if (xlobgetvalue(sym,&val))
  148.     return (val);
  149.  
  150.     /* get the value from the environment list or the global value */
  151.     return (xlygetvalue(sym));
  152. }
  153.  
  154. /* xlygetvalue - get the value of a symbol (no instance variables) */
  155. NODE *xlygetvalue(sym)
  156.   NODE *sym;
  157. {
  158.     NODE *fp,*ep;
  159.  
  160.     /* check the environment list */
  161.     for (fp = xlenv; fp; fp = cdr(fp))
  162.     for (ep = car(fp); ep; ep = cdr(ep))
  163.         if (sym == car(car(ep)))
  164.         return (cdr(car(ep)));
  165.  
  166.     /* return the global value */
  167.     return (getvalue(sym));
  168. }
  169.  
  170. /* xlsetvalue - set the value of a symbol */
  171. xlsetvalue(sym,val)
  172.   NODE *sym,*val;
  173. {
  174.     NODE *fp,*ep;
  175.  
  176.     /* check for this being an instance variable */
  177.     if (xlobsetvalue(sym,val))
  178.     return;
  179.  
  180.     /* look for the symbol in the environment list */
  181.     for (fp = xlenv; fp; fp = cdr(fp))
  182.     for (ep = car(fp); ep; ep = cdr(ep))
  183.         if (sym == car(car(ep))) {
  184.         rplacd(car(ep),val);
  185.         return;
  186.         }
  187.  
  188.     /* store the global value */
  189.     setvalue(sym,val);
  190. }
  191.  
  192. /* xlgetprop - get the value of a property */
  193. NODE *xlgetprop(sym,prp)
  194.   NODE *sym,*prp;
  195. {
  196.     NODE *p;
  197.     return ((p = findprop(sym,prp)) ? car(p) : NIL);
  198. }
  199.  
  200. /* xlputprop - put a property value onto the property list */
  201. xlputprop(sym,val,prp)
  202.   NODE *sym,*val,*prp;
  203. {
  204.     NODE *oldstk,p,*pair;
  205.     if ((pair = findprop(sym,prp)) == NIL) {
  206.     oldstk = xlsave(&p,NULL);
  207.     p.n_ptr = newnode(LIST);
  208.     rplaca(p.n_ptr,prp);
  209.     rplacd(p.n_ptr,pair = newnode(LIST));
  210.     rplaca(pair,val);
  211.     rplacd(pair,cdr(sym->n_symplist));
  212.     rplacd(sym->n_symplist,p.n_ptr);
  213.     xlstack = oldstk;
  214.     }
  215.     rplaca(pair,val);
  216. }
  217.  
  218. /* xlremprop - remove a property from a property list */
  219. xlremprop(sym,prp)
  220.   NODE *sym,*prp;
  221. {
  222.     NODE *last,*p;
  223.     last = NIL;
  224.     for (p = cdr(sym->n_symplist); consp(p) && consp(cdr(p)); p = cdr(last)) {
  225.     if (car(p) == prp)
  226.         if (last)
  227.         rplacd(last,cdr(cdr(p)));
  228.         else
  229.         rplacd(sym->n_symplist,cdr(cdr(p)));
  230.     last = cdr(p);
  231.     }
  232. }
  233.  
  234. /* findprop - find a property pair */
  235. LOCAL NODE *findprop(sym,prp)
  236.   NODE *sym,*prp;
  237. {
  238.     NODE *p;
  239.     for (p = cdr(sym->n_symplist); consp(p) && consp(cdr(p)); p = cdr(cdr(p)))
  240.     if (car(p) == prp)
  241.         return (cdr(p));
  242.     return (NIL);
  243. }
  244.  
  245. /* xlsinit - symbol initialization routine */
  246. xlsinit()
  247. {
  248.     /* initialize the oblist */
  249.     oblist = xlmakesym("*OBLIST*",STATIC);
  250.     setvalue(oblist,newnode(LIST));
  251.     rplaca(getvalue(oblist),oblist);
  252.  
  253.     /* initialize the keyword list */
  254.     keylist = xlsenter("*KEYLIST*");
  255.  
  256.     /* enter the unbound symbol indicator */
  257.     s_unbound = xlsenter("*UNBOUND*");
  258.     setvalue(s_unbound,s_unbound);
  259. }
  260.